home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trans5.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  11.9 KB  |  358 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module trans5)
  13.  
  14.  
  15. (TRANSL-MODULE TRANS5)
  16.  
  17. ;;; these are TRANSLATE properies for the FSUBRS in JPG;COMM >
  18.  
  19. ;;; LDISPLAY is one of the most beastly of all macsyma idiot
  20. ;;; constructs. First of all it makes a variable name and sets it,
  21. ;;; but it evaluates its argument such that
  22. ;;; x:10, LDISPLAY(F(X)) gives  (E1)   F(10)= ...
  23. ;;; LDISPLAY(X) gives X=10 of course. Sometimes it evaluates to get
  24. ;;; the left hand side, and sometimes it doesn't. It has its own
  25. ;;; private fucking version of the macsyma evaluator.
  26. ;;; To see multiple evaluation lossage in the interperter, try
  27. ;;; these: LDISPLAY(F(PRINT("FOOBAR")))$
  28.  
  29. ;;;Totally and absolutely FUCKED
  30. ;;;(DEFUN $LDISPLAY FEXPR (LL) (DISP1 LL T T))
  31. ;;;
  32. ;;;(DEFUN $LDISP FEXPR (LL) (DISP1 LL T NIL))
  33. ;;;
  34. ;;;(DEFUN $DISPLAY FEXPR (LL) (DISP1 LL NIL T))
  35. ;;;
  36. ;;;(DEFUN $DISP FEXPR (LL) (DISP1 LL NIL NIL))
  37. ;;;
  38. ;;;(DEFUN DISP1 (LL LABLIST EQNSP)
  39. ;;; (COND (LABLIST (SETQ LABLIST (NCONS '(MLIST SIMP)))))
  40. ;;; (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
  41. ;;;     ((NULL LL) (OR LABLIST '$DONE))
  42. ;;;     (SETQ L (CAR LL) ANS (MEVAL L))
  43. ;;;     (COND ((AND EQNSP (OR (ATOM ANS) (NOT (EQ (CAAR ANS) 'MEQUAL))))
  44. ;;;        (SETQ ANS (LIST '(MEQUAL) (DISP2 L) ANS))))
  45. ;;;     (COND (LABLIST (COND ((NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (f1+ $LINENUM))))
  46. ;;;            (MAKELABEL $LINECHAR) (NCONC LABLIST (NCONS LINELABLE))
  47. ;;;            (COND ((NOT $NOLABELS) (SET LINELABLE ANS)))))
  48. ;;;     (SETQ TIM (RUNTIME))
  49. ;;;     (DISPLA (LIST '(MLABLE) (COND (LABLIST LINELABLE)) ANS))
  50. ;;;     (MTERPRI)
  51. ;;;     (TIMEORG TIM)))
  52. ;;;
  53. ;;;(DEFUN DISP2 (X)
  54. ;;; (COND ((ATOM X) X)
  55. ;;;       ((EQ (CAAR X) 'MQAPPLY)
  56. ;;;    (CONS '(MQAPPLY) (CONS (CONS (CAADR X) (MAPCAR 'MEVAL (CDADR X)))
  57. ;;;                   (MAPCAR 'MEVAL (CDDR X)))))
  58. ;;;       ((EQ (CAAR X) 'MSETQ) (DISP2 (CADR X)))
  59. ;;;       ((EQ (CAAR X) 'MSET) (DISP2 (MEVAL (CADR X))))
  60. ;;;       ((EQ (CAAR X) 'MLIST) (CONS (CAR X) (MAPCAR 'DISP2 (CDR X))))
  61. ;;;       ((GETL (CAAR X) '(FSUBR FEXPR)) X)
  62. ;;;       (T (CONS (CAR X) (MAPCAR 'MEVAL (CDR X))))))
  63. ;;;
  64.  
  65.  
  66. (DEF%TR $DISP (FORM) 
  67.     `($ANY . (DISPLAY-FOR-TR ,(eq (caar form) '$ldisp)
  68.                  NIL ; equationsp
  69.                  ,@(TR-ARGS (CDR FORM)))))
  70. (DEF-SAME%TR $LDISP $DISP)
  71.  
  72. (DEF%TR $DISPLAY (FORM) 
  73.     `($ANY . (DISPLAY-FOR-TR ,(EQ (CAAR FORM) '$LDISPLAY)
  74.                  T
  75.                  ,@(MAPCAR #'TR-EXP-TO-DISPLAY (CDR FORM)))))
  76.  
  77. (DEF-SAME%TR $LDISPLAY $DISPLAY)
  78.  
  79. ;;; DISPLAY(F(X,Y,FOO()))
  80. ;;; (F X Y (FOO)) => (LET ((&G1 (FOO))) (list '(mequal) (LIST '(F) X Y &G1)
  81. ;;;                                            (F X Y &G1)))
  82. ;;; DISPLAY(X) => (LIST '(MEQUAL) '$X $X)
  83. ;;; DISPLAY(Q[I]) => (LIST '(MEQUAL) (LIST '(Q ARRAY) $I) ...)
  84.  
  85. ;;; Ask me why I did this at lisp level, this should be able
  86. ;;; to be hacked as a macsyma macro. the brain damage I get
  87. ;;; into sometimes...
  88.  
  89. ;;; This walks the translated code attempting to come up
  90. ;;; with a reasonable object for display, expressions which
  91. ;;; might have to get evaluated twice are pushed on the
  92. ;;; VALUE-ALIST (<expression> . <gensym>)
  93. ;;; This is incompatible with the interpreter which evaluates
  94. ;;; arguments to functions twice. Here I only evaluate non-atomic
  95. ;;; things once, and make sure that the order of evaluation is
  96. ;;; pretty much correct. I say "pretty much" because MAKE-VALUES
  97. ;;; does the optmization of not generating a temporary for a variable.
  98. ;;; DISPLAY(FOO(Z,Z:35)) will loose because the second argument will
  99. ;;; be evaluated first. I don't seriously expect anyone to find this
  100. ;;; bug.
  101.  
  102. (DEFVAR VALUE-ALIST NIL)
  103. (DEFUN MAKE-VALUES (EXPR-ARGS)
  104.        (MAPCAR #'(LAMBDA (ARG)
  105.              (COND ((OR (ATOM ARG)
  106.                     (MEMQ (CAR ARG) '(TRD-MSYMEVAL QUOTE)))
  107.                 ARG)
  108.                    (T
  109.                 (LET ((SYM (GENSYM)))
  110.                      (PUSH (CONS ARG SYM) VALUE-ALIST)
  111.                      SYM))))
  112.            EXPR-ARGS))
  113.  
  114.  
  115. (EVAL-WHEN (COMPILE EVAL #-PDP10 LOAD)
  116. #-cl
  117. (DEFSTRUCT (DISP-HACK-OB #+Maclisp TREE #-Maclisp :TREE)
  118.   LEFT-OB RIGHT-OB)
  119. #+cl
  120. (DEFSTRUCT (DISP-HACK-OB (:conc-name nil)( :type list ))  ;;it wanted tree but that's illegal
  121.   LEFT-OB RIGHT-OB)
  122. )
  123.  
  124. (DEFUN OBJECT-FOR-DISPLAY-HACK (EXP)
  125.        (IF (ATOM EXP)
  126.        (MAKE-DISP-HACK-OB
  127.          #+cl :LEFT-OB #-cl LEFT-OB `',EXP
  128.          #+cl :RIGHT-OB #-cl RIGHT-OB EXP)
  129.        (CASE (CAR EXP)
  130.           (SIMPLIFY
  131.            (LET ((V (OBJECT-FOR-DISPLAY-HACK (CADR EXP))))
  132.             (MAKE-DISP-HACK-OB
  133.              #+cl :LEFT-OB #-cl LEFT-OB (LEFT-OB V)
  134.              #+cl :RIGHT-OB #-cl RIGHT-OB `(SIMPLIFY ,(RIGHT-OB V)))))
  135.           (MARRAYREF
  136.            (LET ((VALS (MAKE-VALUES (CDR EXP))))
  137.             (MAKE-DISP-HACK-OB
  138.              #+cl :LEFT-OB #-cl LEFT-OB `(LIST (LIST* ,(CAR VALS) '(ARRAY))
  139.                     ,@(CDR VALS))
  140.              #+cl :RIGHT-OB #-cl RIGHT-OB `(MARRAYREF ,@VALS))))
  141.           (MFUNCTION-CALL
  142.            ; assume evaluation of arguments.
  143.            (LET ((VALS (MAKE-VALUES (CDDR EXP))))
  144.             (MAKE-DISP-HACK-OB
  145.              #+cl :LEFT-OB #-cl LEFT-OB `(LIST '(,(CADR EXP)) ,@VALS)
  146.              #+cl :RIGHT-OB #-cl RIGHT-OB `(MFUNCTION-CALL ,(CADR EXP) ,@VALS))))
  147.           (LIST
  148.            (LET ((OBS (MAPCAR #'OBJECT-FOR-DISPLAY-HACK (CDR EXP))))
  149.             (MAKE-DISP-HACK-OB
  150.              #+cl :LEFT-OB #-cl LEFT-OB `(LIST ,@(MAPCAR #'(LAMBDA (U) (LEFT-OB U))
  151.                           OBS))
  152.              #+cl :RIGHT-OB #-cl RIGHT-OB `(LIST ,@(MAPCAR #'(LAMBDA (U) (RIGHT-OB U))
  153.                            OBS)))))
  154.           (QUOTE (MAKE-DISP-HACK-OB
  155.                #+cl :LEFT-OB #-cl LEFT-OB EXP
  156.                #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
  157.           (TRD-MSYMEVAL
  158.            (MAKE-DISP-HACK-OB
  159.              #+cl :LEFT-OB #-cl LEFT-OB `',(CADR EXP)
  160.              #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
  161.          (T
  162.            (COND ((OR (NOT (ATOM (CAR EXP)))
  163.                   (GETL (CAR EXP) '(FSUBR FEXPR MACRO)))
  164.               (MAKE-DISP-HACK-OB
  165.                 #+cl :LEFT-OB #-cl LEFT-OB `',EXP
  166.                 #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
  167.              (T
  168.               (LET ((VALS (MAKE-VALUES (CDR EXP))))
  169.                    (MAKE-DISP-HACK-OB
  170.                 #+cl :LEFT-OB #-cl LEFT-OB `(LIST '(,(UNTRANS-OP (CAR EXP)))
  171.                            ,@VALS)
  172.                 #+cl :RIGHT-OB #-cl RIGHT-OB `(,(CAR EXP) ,@VALS)))))))))
  173.  
  174. (DEFUN TR-EXP-TO-DISPLAY (EXP)
  175.        (LET* ((LISP-EXP (DTRANSLATE EXP))
  176.           (VALUE-ALIST NIL)
  177.           (OB (OBJECT-FOR-DISPLAY-HACK LISP-EXP))
  178.           (DISP `(LIST '(MEQUAL) ,(LEFT-OB OB) ,(RIGHT-OB OB))))
  179.          (SETQ VALUE-ALIST (NREVERSE VALUE-ALIST))
  180.          (IF VALUE-ALIST
  181.          `((LAMBDA ,(MAPCAR #'CDR VALUE-ALIST) ,DISP)
  182.            ,@(MAPCAR #'CAR VALUE-ALIST))
  183.          DISP)))
  184.  
  185. (DEFUN UNTRANS-OP (OP)
  186.        (OR (CDR (ASSQ OP '((ADD* . MPLUS)
  187.                (SUB* . MMINUS)
  188.                (MUL* . MTIMES)
  189.                (DIV* . MQUOTIENT)
  190.                (POWER* . MEXPT))))
  191.        OP))
  192.  
  193.  
  194. ;;; From RZ;COMBIN >
  195. ;;;
  196. ;;;#+MacLisp
  197. ;;;(defun $cf fexpr (a)
  198. ;;;       (fexprchk a 'cf)
  199. ;;;       (let ((divov (status divov))
  200. ;;;         ($listarith nil))
  201. ;;;        (prog2 (sstatus divov t)
  202. ;;;           (cfeval (meval (car a)))
  203. ;;;           (sstatus divov divov))))
  204. ;;;
  205. ;;;#+Lispm
  206. ;;;(defun $cf fexpr (a)
  207. ;;;       (fexprchk a 'cf)
  208. ;;;       (let (($listarith nil))
  209. ;;;        (cfeval (meval (car a)))))
  210.  
  211. (DEF%TR $CF (FORM)
  212.     (SETQ FORM (CAR (TR-ARGS (CDR FORM))))
  213.     (PUSH-AUTOLOAD-DEF '$CF '(CFEVAL))
  214.     `($ANY . ((LAMBDA (DIVOV $LISTARITH)
  215.               (SSTATUS DIVOV T)
  216.               (UNWIND-PROTECT (CFEVAL ,FORM)
  217.                       (SSTATUS DIVOV DIVOV)))
  218.           (STATUS DIVOV)
  219.           NIL)))
  220.  
  221. ;;; from RZ;TRGRED >
  222. ;;;
  223. ;;;(DEFUN $TRIGREDUCE FEXPR (L)
  224. ;;;    ((LAMBDA (*TRIGRED VAR *NOEXPAND $TRIGEXPAND $VERBOSE $RATPRINT)
  225. ;;;    (GCDRED (SP1 (MEVAL (CAR L)))))
  226. ;;;     T (COND ((CDR L) (MEVAL (CADR L)))
  227. ;;;         ( '*NOVAR ))
  228. ;;;     T NIL NIL NIL))
  229.  
  230. ; JPG made this an LSUBR now! win win win good old Jeff.
  231. ;(DEF%TR $TRIGREDUCE (FORM)
  232. ;    (LET ((ARG1 (DTRANSLATE (CADR FORM)))
  233. ;          (ARG2 (COND ((CDDR FORM) (DTRANSLATE (CADDR FORM)))
  234. ;              (T ''*NOVAR))))
  235. ;         `($ANY . #%(LET ((*TRIGRED T)
  236. ;                  (VAR ,ARG2)
  237. ;                  (*NOEXPAND T)
  238. ;                  ($TRIGEXPAND NIL)
  239. ;                  ($VERBOSE NIL)
  240. ;                  ($RATPRINT NIL))
  241. ;                 ; gross hack, please fix me quick gjc!!!!
  242. ;                 (OR (SYMBOL-PLIST 'GCDRED) (LOAD (GET '$TRIGREDUCE 'AUTOLOAD)))
  243. ;                 (GCDRED (SP1 ,ARG1))))))
  244.  
  245. ;;; From MATRUN
  246. ;;; (DEFUN $APPLY1 FEXPR (L)
  247. ;;;       (PROG (*EXPR)
  248. ;;;         (SETQ *EXPR (MEVAL (CAR L)))
  249. ;;;         (MAPC (FUNCTION (LAMBDA (Z)
  250. ;;;                     (SETQ *EXPR (APPLY1 *EXPR Z 0))))
  251. ;;;           (CDR L))
  252. ;;;         (RETURN *EXPR)))
  253.  
  254. (DEF%TR $APPLY1 (FORM &AUX
  255.               (EXPR (TR-GENSYM))
  256.               (RULES (TR-GENSYM)))
  257.     (PUSH-AUTOLOAD-DEF '$APPLY1 '(APPLY1))
  258.               
  259.     `($ANY  . (DO ((,EXPR ,(DTRANSLATE (CADR FORM))
  260.                    (APPLY1 ,EXPR (CAR ,RULES) 0))
  261.                (,RULES ',(CDDR FORM) (CDR ,RULES)))
  262.               ((NULL ,RULES) ,EXPR))))
  263.  
  264. ;;; This code was written before they had formatting of lisp code invented.
  265. ;;;(DEFUN $APPLY2 FEXPR (L)(PROG (*RULELIST)
  266. ;;;(SETQ *RULELIST (CDR L))
  267. ;;;(RETURN (APPLY2 (MEVAL (CAR L)) 0))))
  268.  
  269. (DEF%TR $APPLY2 (FORM)
  270.     `($ANY . ((LAMBDA (*RULELIST)
  271.               (DECLARE (SPECIAL *RULELIST))
  272.               (APPLY2 ,(DTRANSLATE (CADR FORM)) 0))
  273.           ',(CDDR FORM))))
  274.  
  275. ;;;(DEFUN $APPLYB1 FEXPR (L) 
  276. ;;;     (PROG (*EXPR) 
  277. ;;;           (SETQ *EXPR (MEVAL (CAR L)))
  278. ;;;           (MAPC (FUNCTION (LAMBDA (Z) 
  279. ;;;                       (SETQ *EXPR(CAR
  280. ;;;                         (APPLY1HACK *EXPR
  281. ;;;                             Z)))))
  282. ;;;             (CDR L))
  283. ;;;           (RETURN *EXPR )))
  284.  
  285. (DEF%TR $APPLYB1 (FORM &AUX (EXPR (TR-GENSYM)) (RULES (TR-GENSYM)))
  286.     (PUSH-AUTOLOAD-DEF '$APPLYB1 '(APPLY1HACK))
  287.     `($ANY . (DO ((,EXPR ,(DTRANSLATE (CADR FORM))
  288.                  (CAR (APPLY1HACK ,EXPR (CAR ,RULES))))
  289.               (,RULES ',(CDDR FORM) (CDR ,RULES)))
  290.              ((NULL ,RULES) ,EXPR))))
  291.  
  292. ;;;(DEFUN $APPLYB2 FEXPR (L)(PROG (*RULELIST)
  293. ;;;(SETQ *RULELIST (CDR L))
  294. ;;;(RETURN(CAR (APPLY2HACK (MEVAL (CAR L)))))))
  295.  
  296. (DEF%TR $APPLYB2 (FORM)
  297.     (PUSH-AUTOLOAD-DEF '$APPLYB2 '(APPLY2HACK))
  298.     `($ANY . ((LAMBDA (*RULELIST)
  299.               (DECLARE (SPECIAL *RULELIST))
  300.               (APPLY2HACK ,(DTRANSLATE (CADR FORM))))
  301.           ',(CDDR FORM))))
  302.  
  303.  
  304.  
  305. ;;; this nice translation property written by REH.
  306. ;;; He is the first macsyma system program to ever
  307. ;;; write the translation property for his own special form!
  308.  
  309.  
  310. (DEF%TR $BUILDQ (FORM)
  311.  
  312.  (LET ((ALIST                               ;would be nice to output
  313.         (MAPCAR                     ;backquote instead of list/cons
  314.       #'(LAMBDA (VAR)            ;but I'm not sure if things get
  315.              (COND ((ATOM VAR)              ;macroexpanded.  -REH
  316.                                             ; Well, any macros are o.k. They
  317.                                     ; get expanded "at the right time". -gjc
  318.             
  319.                     `(CONS ',VAR ,(DTRANSLATE VAR)))
  320.                    ((EQ (CAAR VAR) 'MSETQ)
  321.                     `(CONS ',(CADR VAR) ,(DTRANSLATE (CADDR VAR))))
  322.                    (T (SETQ TR-ABORT T)
  323.                       (TR-TELL VAR
  324.                 "Illegal BUILDQ form encountered during translation"))))
  325.                        ;right thing to do here??
  326.                        ;how much error checking does transl do now?
  327.                        ; Yes. Not as much as it should! -GJC
  328.       
  329.          (CDR (CADR FORM)))))
  330.       (COND ((NULL ALIST) 
  331.                `($ANY QUOTE ,(CADDR FORM)))
  332.             (T `($ANY MBUILDQ-SUBST (LIST ,@ALIST) ',(CADDR FORM))))))
  333.  
  334.  
  335. ;;; Presently STATUS and SSTATUS are FEXPR which don't evaluate 
  336. ;;; their arguments. 
  337.  
  338. #-cl
  339. (def%tr $sstatus (form)
  340.     `($any . ($sstatus . ,(cdr form))))
  341.  
  342. #-cl
  343. (def%tr $status (form)
  344.     (setq form (cdr form))
  345.     (cond ((null form) ; %%%PLEASE FIX ME%%% with WNA-CHECKING %%%%%%
  346.            nil)
  347.           (t
  348.            (case (car form)
  349.               ($FEATURE
  350.                (cond ((null (cdr form))
  351.                   `($any . ($status $feature)))
  352.                  ; this BOOLEAN check is important, since
  353.                  ; STATUS(FEATURE,FOO) will always be used in a
  354.                  ; BOOLEAN context.
  355.                  (t `($BOOLEAN . ($STATUS $FEATURE ,(CADR FORM))))))
  356.               (T `($ANY . ($STATUS . ,FORM)))))))
  357.  
  358.